Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/fldpak/fpdemo2e.frm

Visual Basic Form | 1993-11-08 | 20.0 KB | 580 lines

VERSION 2.00
Begin Form EditFrm
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Multi-Sortable Address Book (FieldPack demo program 2)"
   ClientHeight    =   2895
   ClientLeft      =   1380
   ClientTop       =   2850
   ClientWidth     =   7215
   ClipControls    =   0   'False
   Height          =   3585
   Icon            =   FPDEMO2E.FRX:0000
   Left            =   1320
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   2895
   ScaleWidth      =   7215
   Top             =   2220
   Width           =   7335
   Begin TextBox txtFindString
      Height          =   315
      Left            =   1320
      TabIndex        =   23
      Top             =   2460
      Width           =   1155
   End
   Begin ListBox lstSortingListBox
      Height          =   225
      Left            =   0
      Sorted          =   -1  'True
      TabIndex        =   22
      Top             =   0
      Visible         =   0   'False
      Width           =   1545
   End
   Begin CommandButton cmdSort
      Caption         =   "Sort by..."
      Height          =   315
      Left            =   5880
      TabIndex        =   21
      Top             =   300
      Width           =   1215
   End
   Begin CommandButton cmdNew
      Caption         =   "New"
      Height          =   315
      Left            =   5880
      TabIndex        =   20
      Top             =   1080
      Width           =   1215
   End
   Begin CommandButton cmdFind
      Caption         =   "<--  Find (in current sort field)"
      Height          =   315
      Left            =   2610
      TabIndex        =   19
      Top             =   2460
      Width           =   2805
   End
   Begin CommandButton cmdReport
      Caption         =   "Report"
      Height          =   315
      Left            =   5880
      TabIndex        =   18
      Top             =   2460
      Width           =   1215
   End
   Begin VScrollBar vscrScroller
      Height          =   1755
      Left            =   5520
      Min             =   1
      TabIndex        =   7
      Top             =   600
      Value           =   1
      Width           =   255
   End
   Begin CommandButton cmdDelete
      Caption         =   "Delete"
      Height          =   315
      Left            =   5880
      TabIndex        =   8
      Top             =   1500
      Width           =   1215
   End
   Begin TextBox txtPhone
      Height          =   315
      Left            =   3000
      TabIndex        =   6
      Top             =   2040
      Width           =   2415
   End
   Begin TextBox txtAreaCode
      Height          =   315
      Left            =   1320
      TabIndex        =   5
      Top             =   2040
      Width           =   855
   End
   Begin TextBox txtZip
      Height          =   315
      Left            =   4080
      TabIndex        =   4
      Top             =   1680
      Width           =   1335
   End
   Begin TextBox txtState
      Height          =   315
      Left            =   1320
      TabIndex        =   3
      Top             =   1680
      Width           =   855
   End
   Begin TextBox txtCity
      Height          =   315
      Left            =   1320
      TabIndex        =   2
      Top             =   1320
      Width           =   4095
   End
   Begin TextBox txtAddress
      Height          =   315
      Left            =   1320
      TabIndex        =   1
      Top             =   960
      Width           =   4095
   End
   Begin TextBox txtName
      Height          =   315
      Left            =   1320
      TabIndex        =   0
      Top             =   600
      Width           =   4095
   End
   Begin Label lblCurrentSortField
      FontBold        =   -1  'True
      FontItalic      =   -1  'True
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   225
      Left            =   4440
      TabIndex        =   25
      Top             =   300
      Width           =   1215
   End
   Begin Label Label9
      Alignment       =   1  'Right Justify
      Caption         =   "...in sort sequence by:"
      Height          =   225
      Left            =   2400
      TabIndex        =   24
      Top             =   300
      Width           =   1995
   End
   Begin Label lblRecordID
      Caption         =   " 0 of 0"
      Height          =   195
      Left            =   1380
      TabIndex        =   17
      Top             =   300
      Width           =   975
   End
   Begin Label Label8
      Alignment       =   1  'Right Justify
      Caption         =   "Record:"
      Height          =   195
      Left            =   60
      TabIndex        =   16
      Top             =   300
      Width           =   1215
   End
   Begin Label Label7
      Alignment       =   1  'Right Justify
      Caption         =   "Phone:"
      Height          =   195
      Left            =   2220
      TabIndex        =   15
      Top             =   2100
      Width           =   735
   End
   Begin Label Label6
      Alignment       =   1  'Right Justify
      Caption         =   "Area Code:"
      Height          =   195
      Left            =   60
      TabIndex        =   14
      Top             =   2100
      Width           =   1215
   End
   Begin Label Label5
      Alignment       =   1  'Right Justify
      Caption         =   "Zip:"
      Height          =   195
      Left            =   3420
      TabIndex        =   13
      Top             =   1740
      Width           =   615
   End
   Begin Label Label4
      Alignment       =   1  'Right Justify
      Caption         =   "State:"
      Height          =   195
      Left            =   60
      TabIndex        =   12
      Top             =   1740
      Width           =   1215
   End
   Begin Label Label3
      Alignment       =   1  'Right Justify
      Caption         =   "City:"
      Height          =   195
      Left            =   60
      TabIndex        =   11
      Top             =   1380
      Width           =   1215
   End
   Begin Label Label2
      Alignment       =   1  'Right Justify
      Caption         =   "Address:"
      Height          =   195
      Left            =   60
      TabIndex        =   10
      Top             =   1020
      Width           =   1215
   End
   Begin Label Label1
      Alignment       =   1  'Right Justify
      Caption         =   "Name:"
      Height          =   195
      Left            =   60
      TabIndex        =   9
      Top             =   660
      Width           =   1215
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu mnuHelp
      Caption         =   "&Help"
      Begin Menu mnuAbout
         Caption         =   "&About"
      End
   End
Option Explicit
'FieldPack Demo Program 2
'November 1993
'Software Source
'Fremont, California
'tel [phone]
'fax [phone]
'Original programming, including all the
'really clever report-generation work,
'by Don Wanless
'Rewrite and debugging, including the
'tricky New/Delete/Change stuff, and
'pedantic commentary and variable
'renaming, by Sam Cohen
Sub AdjustScrollerRange ()
        Dim i As Integer
        ScrollerChangeEnabled = False
        vscrScroller.Max = NumberOfRecords
        i% = NumberOfRecords / 10
        If i% < 1 Then i% = 1
        vscrScroller.LargeChange = i%
        ScrollerChangeEnabled = True
End Sub
Function BuildRecord () As String
    Dim rec    As String
    Dim wname  As String
    Dim firstn As String
    Dim lastn  As String
    Dim n      As Integer
    wname$ = txtName.Text
    n% = DS_CountDlms(wname$, ",")
    If n% = 0 Then
        ' no comma, so assume firstname [middle] lastname
        wname$ = US_Trim(wname$)
        n% = DS_CountDlms(wname$, " ")
        If n% Then
            lastn$ = DS_GetField(wname$, " ", n% + 1)
            firstn$ = Left$(wname$, DS_FindDlm(wname$, " ", n%) - 1)
            wname$ = lastn$ + ", " + firstn$
        Else
            ' no blanks, use as is
        End If
    ElseIf n% = 1 Then
        ' one comma, so assume lastname, first..., use as is
    Else
        ' more than one comma, ???, use as is
    End If
    rec$ = ""
    rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_NAME, US_Proper(wname$))
    rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_ADDRESS, US_Proper((txtAddress.Text)))
    rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_CITY, US_Proper((txtCity.Text)))
    rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_STATE, UCase((txtState.Text)))
    rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_ZIP, (txtZip.Text))
    rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_AREACODE, (txtAreaCode.Text))
    rec$ = DS_PutField(rec$, FldDlm$, FIELDNUMBER_PHONE, (txtPhone.Text))
    'Rearrange so that the proper sort field is in front:
    rec$ = DS_GetField(rec$, FldDlm$, FirstField) + FldDlm$ + DS_RemoveField(rec$, FldDlm$, FirstField)
    BuildRecord$ = rec$
End Function
Sub cmdDelete_Click ()
    Dim tmp As String
    If FlagNewRecordInProgress Then 'User hit "Delete" to cancel a "New" rec (which isn't really there).
        FlagNewRecordInProgress = False
    Else
        tmp$ = DS_RemoveField(DatabaseMemoryBuffer$, RecDlm$, CurrentRecordNumber)
        DatabaseMemoryBuffer$ = tmp$
        cmdFind.Enabled = False
        lblCurrentSortField.Enabled = False
        FlagFileChanged = True
    End If
    NumberOfRecords = NumberOfRecords - 1
    If CurrentRecordNumber = 1 Then '(code to handle boundary conditions...)
        If NumberOfRecords = 0 Then
            CurrentRecordNumber = 0
        Else
            CurrentRecordNumber = NumberOfRecords   '(Show last rec if we just deleted first rec.)
        End If
    Else
        CurrentRecordNumber = CurrentRecordNumber - 1   '(Normally, show previous record.)
    End If
    AdjustScrollerRange
    DisplayRecord
End Sub
Sub cmdFind_Click ()
    Dim i   As Integer
    Dim FindMe As String
    UpdateIfNecessary
    FindMe$ = txtFindString.Text
    i% = DS_FindField(DatabaseMemoryBuffer$, RecDlm$, 1, FindMe$, 2 + 4) ' case insensitive find "equal to or beginning with"
    If i% < 0 Then
        i% = -i%
    End If
    If i% Then
        CurrentRecordNumber = i%
        DisplayRecord
    End If
End Sub
Sub cmdNew_Click ()
    'Note that this does NOT put a blank record into the database.
    'Instead, it (falsely) increments "NumberOfRecords" and sets
    'CurrentRecordNumber to a fictitious new record at the end
    'of the database.  (This is not good programming technique;
    'it's dangerous to lie to yourself.)
    UpdateIfNecessary
    TextChangeEnabled = False
    txtName.Text = ""
    txtAddress.Text = ""
    txtCity.Text = ""
    txtState.Text = ""
    txtZip.Text = ""
    txtAreaCode.Text = ""
    txtPhone.Text = ""
    NumberOfRecords = NumberOfRecords + 1
    CurrentRecordNumber = NumberOfRecords
    AdjustScrollerRange
    vscrScroller.Value = CurrentRecordNumber
    lblRecordID.Caption = Str$(CurrentRecordNumber) + " of" + Str$(NumberOfRecords)
    FlagNewRecordInProgress = True
    FlagRecordChanged = False
    TextChangeEnabled = True
    txtName.SetFocus
End Sub
Sub cmdReport_Click ()
    UpdateIfNecessary
    ReportFrm.Show 1
End Sub
Sub cmdSort_Click ()
    UpdateIfNecessary
    txtFindString.Text = ""   'Clean up
    ' select sort field
    SortFrm.Show 1
    If SortForm_OK_or_Cancel = 1 Then
        Exit Sub
    End If
    SortRecords
    DisplayRecord
End Sub
Sub DisplayRecord ()
    Dim rec As String
    TextChangeEnabled = False   'Otherwise, setting values into text boxes in
                                'code would trigger a change event!
    If CurrentRecordNumber > 0 Then
        rec$ = DS_GetField(DatabaseMemoryBuffer$, RecDlm$, CurrentRecordNumber)
        'Rearrange record in "normal" field order for simplicity of field extraction:
        rec$ = DS_InsertField(DS_RemoveField(rec$, FldDlm$, 1), FldDlm$, FirstField, DS_GetField(rec$, FldDlm$, 1))
        txtName.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_NAME)
        txtAddress.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_ADDRESS)
        txtCity.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_CITY)
        txtState.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_STATE)
        txtZip.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_ZIP)
        txtAreaCode.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_AREACODE)
        txtPhone.Text = DS_GetField(rec$, FldDlm$, FIELDNUMBER_PHONE)
    Else
        txtName.Text = ""
        txtAddress.Text = ""
        txtCity.Text = ""
        txtState.Text = ""
        txtZip.Text = ""
        txtAreaCode.Text = ""
        txtPhone.Text = ""
        NumberOfRecords = 1
        CurrentRecordNumber = 1
        FlagNewRecordInProgress = True
    End If
    lblRecordID.Caption = Str$(CurrentRecordNumber) + " of" + Str$(NumberOfRecords)
    vscrScroller.Value = CurrentRecordNumber
    FlagRecordChanged = False   'Initialize trigger.
    TextChangeEnabled = True    'Enable trigger.
    txtName.SetFocus
End Sub
Sub Form_Load ()
    Dim fh    As Integer
    Dim rc    As Integer
    Dim l     As Long
    rc% = FP_Password("Sorry, you'll have to register FIELDPACK to get a password.")
    RecDlm$ = Chr$(13) + Chr$(10)  'CRLF (Carriage-return/line-feed)
    FldDlm$ = ";"
    fh = FreeFile
    DatabaseFileName$ = "c:\fpdemo2.dat"
    Open DatabaseFileName$ For Binary As #fh
    l& = LOF(fh)
    If l& > 65530 Then  '(actually, 65536 -- but I don't trust Microsoft...)
        MsgBox "File too big (over 64KB)!", 48, "FieldPack Demo Program 2"
        End
    End If
    DatabaseMemoryBuffer$ = String$(l&, " ")  'See the next line of code...
    Get #fh, , DatabaseMemoryBuffer$    'Read entire file contents into memory (max 64 KB!!).
    Close #fh
    'Normally (see SaveIntoFile procedure), there's a final CRLF, after the last piece of data;
    'we'll remove it, if it's there.
    NumberOfRecords = DS_CountDlms(DatabaseMemoryBuffer$, RecDlm$)
    DatabaseMemoryBuffer$ = DS_RemoveField(DatabaseMemoryBuffer$, RecDlm$, NumberOfRecords + 1)
    If DatabaseMemoryBuffer = "" Then NumberOfRecords = 0
    AdjustScrollerRange
    FirstField = 1
    SortField = 1
    lblCurrentSortField.Enabled = True
    lblCurrentSortField.Caption = "Name"
    If NumberOfRecords = 0 Then
        CurrentRecordNumber = 0
    Else
        SortRecords 'This is redundant (see SaveIntoFile procedure), but whatthehell...
        CurrentRecordNumber = 1
    End If
    FlagFileChanged = False
    FlagRecordChanged = False
    FlagNewRecordInProgress = False
    EditFrm.Show    'Necessary because of the SetFocus
                    'call in the DisplayRecord procedure.
    DisplayRecord
End Sub
Sub mnuAbout_Click ()
    AboutFrm.Show 1
End Sub
Sub mnuExit_Click ()
    UpdateIfNecessary
    If FlagFileChanged Then
        SortField = 1  'We chose to always save the file sorted by "Name."
        SortRecords
        SaveIntoFile
    End If
    Unload EditFrm  'Bye...
End Sub
Sub SaveIntoFile ()
    Dim fh   As Integer
    Dim crlf As String
    crlf$ = Chr$(13) + Chr$(10)
    fh = FreeFile
    Kill DatabaseFileName$  'If we didn't do this, we couldn't shorten the file contents.
    Open DatabaseFileName$ For Binary As #fh
    Put #fh, , DatabaseMemoryBuffer$
    Put #fh, , crlf$    'We add a final CRLF so that text editors can read the file; each
                        'record appears as a line of text.  See Form_Load.
    Close #fh
    FlagFileChanged = False 'We put this here in case you want to expand this example
                            'into a more sophisticated program, with a "Save" menu item
                            '(and maybe also "Open," "Save As," etc.)
End Sub
Sub SortRecords ()
    Dim i   As Integer
    Dim rec As String
    Dim sf  As String
    ' sort the items using a sorted list box
    ' clear the list box
    lstSortingListBox.Clear
    ' load items into list box from our buffer...
    For i% = 1 To NumberOfRecords
        rec$ = DS_GetField(DatabaseMemoryBuffer$, RecDlm$, i%)
        'First, rearrange record in "normal" field order for simplicity of field extraction:
        rec$ = DS_InsertField(DS_RemoveField(rec$, FldDlm$, 1), FldDlm$, FirstField, DS_GetField(rec$, FldDlm$, 1))
        'Now, rearrange so that the newly-chosen sort field is in front:
        rec$ = DS_InsertField(DS_RemoveField(rec$, FldDlm$, SortField), FldDlm$, 1, DS_GetField(rec$, FldDlm$, SortField))
        lstSortingListBox.AddItem rec$
    Next i%
    ' clear our buffer
    DatabaseMemoryBuffer$ = ""
    ' Take records from list box (now in sort sequence) and put them back into our buffer.
    For i% = 1 To NumberOfRecords
        DatabaseMemoryBuffer$ = DS_PutField(DatabaseMemoryBuffer$, RecDlm$, i%, (lstSortingListBox.List(i% - 1)))
    Next i%
    FlagFileChanged = 1
    ' clear list box to give memory back
    lstSortingListBox.Clear
    ' Record the new database field arrangement:
    FirstField = SortField
    ' show the first record (whoever called us will then call DisplayRecord)
    CurrentRecordNumber = 1
    cmdFind.Enabled = True
    lblCurrentSortField.Enabled = True
End Sub
Sub txtAddress_Change ()
    If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtAreaCode_Change ()
    If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtCity_Change ()
    If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtName_Change ()
    If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtPhone_Change ()
    If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtState_Change ()
    If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub txtZip_Change ()
    If TextChangeEnabled Then FlagRecordChanged = True
End Sub
Sub UpdateIfNecessary ()
    'This routine should be called everywhere there's an indication that the user
    'may be finished looking at a displayed record.
    Dim rec As String
    If FlagRecordChanged Then   '(Whether old record or new record...)
        rec$ = BuildRecord()
        If (Len(rec$) < (65530 - Len(DatabaseMemoryBuffer$))) Then
            DatabaseMemoryBuffer$ = DS_PutField(DatabaseMemoryBuffer$, RecDlm$, CurrentRecordNumber, rec$)
            FlagFileChanged = True
            cmdFind.Enabled = False
            lblCurrentSortField.Enabled = False
            FlagNewRecordInProgress = False
        Else
            MsgBox "Changes not saved -- database too large (64KB limit).", 48, "FieldPack Demo Program 2"
        End If
        FlagRecordChanged = False
    ElseIf FlagNewRecordInProgress Then '(User had a "New" record up, but didn't enter anything.)
        NumberOfRecords = NumberOfRecords - 1
        CurrentRecordNumber = CurrentRecordNumber - 1
        AdjustScrollerRange
        FlagNewRecordInProgress = False
        DisplayRecord   'Display the last record in the buffer.  (If none, will put up "New" rec.)
    End If
End Sub
Sub vscrScroller_Change ()
    If ScrollerChangeEnabled Then UpdateIfNecessary
    If vscrScroller.Value = 0 Then
        CurrentRecordNumber = 1
    Else
        CurrentRecordNumber = vscrScroller.Value
    End If
    DisplayRecord
End Sub
Sub vscrScroller_Scroll ()
    UpdateIfNecessary
    If vscrScroller.Value = 0 Then
        CurrentRecordNumber = 1
    Else
        CurrentRecordNumber = vscrScroller.Value
    End If
    DisplayRecord
End Sub